home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / uim / key.scm < prev    next >
Encoding:
Text File  |  2010-11-07  |  10.6 KB  |  351 lines
  1. ;;;
  2. ;;; Copyright (c) 2003-2009 uim Project http://code.google.com/p/uim/
  3. ;;;
  4. ;;; All rights reserved.
  5. ;;;
  6. ;;; Redistribution and use in source and binary forms, with or without
  7. ;;; modification, are permitted provided that the following conditions
  8. ;;; are met:
  9. ;;; 1. Redistributions of source code must retain the above copyright
  10. ;;;    notice, this list of conditions and the following disclaimer.
  11. ;;; 2. Redistributions in binary form must reproduce the above copyright
  12. ;;;    notice, this list of conditions and the following disclaimer in the
  13. ;;;    documentation and/or other materials provided with the distribution.
  14. ;;; 3. Neither the name of authors nor the names of its contributors
  15. ;;;    may be used to endorse or promote products derived from this software
  16. ;;;    without specific prior written permission.
  17. ;;;
  18. ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND
  19. ;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
  20. ;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  21. ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE
  22. ;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  23. ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
  24. ;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
  25. ;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
  26. ;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  27. ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
  28. ;;; SUCH DAMAGE.
  29. ;;;;
  30.  
  31. (require "util.scm")
  32.  
  33. ;; config
  34. (define enable-emacs-like-key-prefix? #t)
  35.  
  36. ;; valid-key-symbols is defined in uim-key.c
  37.  
  38. (define key-symbol?
  39.   (lambda (sym)
  40.     (member sym valid-key-symbols)))
  41.  
  42. (define intern-key-symbol
  43.   (lambda (key-str)
  44.     (let ((sym (string->symbol key-str)))
  45.       (if (memq sym valid-key-symbols)
  46.       sym
  47.       #f))))
  48.  
  49. ;
  50. (define shift-key-mask
  51.   (lambda (state)
  52.     (= (bitwise-and state 1) 1)))
  53. (define control-key-mask
  54.   (lambda (state)
  55.     (= (bitwise-and state 2) 2)))
  56. (define alt-key-mask
  57.   (lambda (state)
  58.     (= (bitwise-and state 4) 4)))
  59. (define meta-key-mask
  60.   (lambda (state)
  61.     (= (bitwise-and state 8) 8)))
  62. (define super-key-mask
  63.   (lambda (state)
  64.     (= (bitwise-and state 64) 64)))
  65. (define hyper-key-mask
  66.   (lambda (state)
  67.     (= (bitwise-and state 128) 128)))
  68.  
  69. (define modifier-key-mask
  70.   (lambda (state)
  71.     (> state 0)))
  72.  
  73. (define modifier-key?
  74.   (lambda (key key-state)
  75.     (or
  76.      (eq? key 'Shift_key)
  77.      (eq? key 'Control_key)
  78.      (eq? key 'Alt_key)
  79.      (eq? key 'Meta_key)
  80.      (eq? key 'Super_key)
  81.      (eq? key 'Hyper_key))))
  82.  
  83. (define key-state-alist
  84.   '((Shift_key   . 1)
  85.     (Control_key . 2)
  86.     (Alt_key     . 4)
  87.     (Meta_key    . 8)
  88.     (Super_key   . 64)
  89.     (Hyper_key   . 128)))
  90.  
  91. (define emacs-like-prefix-alist
  92.   '(("S" . Shift_key)
  93.     ("C" . Control_key)
  94.     ("A" . Alt_key)
  95.     ("M" . Meta_key)
  96.     ("Z" . Super_key)
  97.     ("H" . Hyper_key)
  98.     ("I" . IgnoreCase)
  99.     ("J" . IgnoreShift)
  100.     ("K" . IgnoreRegularShift)))
  101.  
  102. (define tag-prefix-alist
  103.   '(("Shift"              . Shift_key)
  104.     ("Control"            . Control_key)
  105.     ("Alt"                . Alt_key)
  106.     ("Meta"               . Meta_key)
  107.     ("Super"              . Super_key)
  108.     ("Hyper"              . Hyper_key)
  109.     ("IgnoreCase"         . IgnoreCase)
  110.     ("IgnoreShift"        . IgnoreShift)
  111.     ("IgnoreRegularShift" . IgnoreRegularShift)))
  112.  
  113. (define translator-prefix?
  114.   (lambda (symbol)
  115.     (or (eq? symbol 'IgnoreCase)
  116.     (eq? symbol 'IgnoreShift)
  117.     (eq? symbol 'IgnoreRegularShift))))
  118.  
  119. ;;
  120. (define intern-key-prefix
  121.   (lambda (symbol-str alist)
  122.     (let ((pair (assoc symbol-str alist)))
  123.       (and pair
  124.        (cdr pair)))))
  125.  
  126. (define parse-tag-prefix-symbol
  127.   (lambda (parsed char-list)
  128.     (let ((prefix (if (string=? parsed "")
  129.               #f
  130.               (intern-key-prefix parsed tag-prefix-alist))))
  131.       (if (not (null? char-list))
  132.       (let* ((head (car char-list))
  133.          (head-char (string->charcode head))
  134.          (rest (cdr char-list)))
  135.         (if (or (ichar-alphabetic? head-char)
  136.             (ichar-numeric? head-char)
  137.             (string=? head "_"))
  138.         (parse-tag-prefix-symbol (string-append parsed head) rest)
  139.         (cons prefix char-list)))
  140.       (cons prefix ())))))
  141.  
  142. (define parse-tag-prefix
  143.   (lambda (str)
  144.     (if (not (string=? str ""))
  145.     (let* ((char-list (reverse (string-to-list str)))
  146.            (head (car char-list)))
  147.       (if (string=? head "<")
  148.           (let* ((parsed (parse-tag-prefix-symbol "" (cdr char-list)))
  149.              (prefix (car parsed))
  150.              (rest (cdr parsed)))
  151.         (if (and (not (null? rest))
  152.              (string=? (car rest) ">"))
  153.             (cons prefix
  154.               (if (null? (cdr rest))
  155.                   ""
  156.                   (apply string-append (cdr rest))))
  157.             (cons #f str)))
  158.           (cons #f str)))
  159.     (cons #f str))))
  160.  
  161. (define parse-emacs-like-prefix
  162.   (lambda (str)
  163.     (let* ((char-list (reverse (string-to-list str)))
  164.        (prefix-str (and (<= 2 (length char-list))
  165.             (string=? (nth 1 char-list) "-")
  166.             (car char-list)))
  167.        (prefix (intern-key-prefix prefix-str emacs-like-prefix-alist))
  168.        (rest (if prefix
  169.              (apply string-append (cddr char-list))
  170.              str)))
  171.       (cons prefix rest))))
  172.  
  173. (define parse-key-prefix
  174.   (lambda (str)
  175.     (let* ((parsed-as-emacs (parse-emacs-like-prefix str))
  176.        (emacs-prefix (car parsed-as-emacs)))
  177.       (or (and enable-emacs-like-key-prefix?
  178.            emacs-prefix
  179.            parsed-as-emacs)
  180.       (parse-tag-prefix str)))))
  181.  
  182. (define parse-key-str
  183.   (lambda (str translators key key-state)
  184.     (let ((str-len (string-length str)))
  185.       (cond
  186.        ((= str-len 0)
  187.     (list "" translators key key-state))
  188.        ((= str-len 1)
  189.     (list "" translators (string->charcode str) key-state))
  190.        ((<= 2 str-len)
  191.     (let* ((parsed (parse-key-prefix str))
  192.            (prefix (car parsed))
  193.            (rest (cdr parsed)))
  194.       (cond
  195.        ((modifier-key? prefix 0)
  196.         (let ((key-state (bitwise-ior key-state
  197.                       (cdr (assq prefix key-state-alist)))))
  198.           (parse-key-str rest translators key key-state)))
  199.        ((translator-prefix? prefix)
  200.         (let* ((translator
  201.             (cond
  202.              ((eq? prefix 'IgnoreCase)
  203.               (lambda (key key-state)
  204.             (let ((translated-key (ichar-downcase key)))
  205.               (list translated-key key-state))))
  206.              ((eq? prefix 'IgnoreShift)
  207.               (lambda (key key-state)
  208.             (let ((translated-key-state
  209.                    (bitwise-and key-state
  210.                         (bitwise-not 1))))
  211.               (list key translated-key-state))))
  212.              ((eq? prefix 'IgnoreRegularShift)
  213.               (lambda (key key-state)
  214.             (let ((translated-key-state
  215.                    (if (ichar-graphic? key)
  216.                    (bitwise-and key-state
  217.                         (bitwise-not 1))
  218.                    key-state)))
  219.               (list key translated-key-state))))))
  220.            (translators (cons translator
  221.                       translators)))
  222.           (parse-key-str rest translators key key-state)))
  223.        (else
  224.         (let* ((key-symbol (intern-key-symbol str))
  225.            (key (or key-symbol
  226.                 key))
  227.            (rest (if key-symbol
  228.                  ""
  229.                  rest)))
  230.           (list rest translators key key-state))))))))))
  231.  
  232. (define apply-translators
  233.   (lambda (translators key key-state)
  234.     (if (null? translators)
  235.     (list translators key key-state)
  236.     (let* ((translator (car translators))
  237.            (rest-translators (cdr translators))
  238.            (translated (translator key key-state))
  239.            (translated-key (car translated))
  240.            (translated-state (cadr translated)))
  241.       (apply-translators
  242.        rest-translators
  243.        translated-key
  244.        translated-state)))))
  245.  
  246. ;; Generates key predicate
  247. ;; (make-single-key-predicate "<Control>j")
  248. (define make-single-key-predicate
  249.   (lambda (source)
  250.     (cond
  251.      ((string? source)
  252.       (let* ((key-str source)
  253.          (parsed (parse-key-str key-str () -1 0))
  254.          (translated (apply apply-translators (cdr parsed)))
  255.          (translators  (nth 1 parsed))
  256.          (target-key   (nth 1 translated))
  257.          (target-state (nth 2 translated)))
  258.     (lambda (key key-state)
  259.       (let* ((translated (apply-translators translators key key-state))
  260.          (key       (nth 1 translated))
  261.          (key-state (nth 2 translated)))
  262.         (and (eqv? key target-key)
  263.          (eqv? key-state target-state))))))
  264.      ((symbol? source)
  265.       (let ((predicate-sym source))
  266.     (lambda (key key-state)
  267.       ((symbol-value predicate-sym) key key-state))))
  268.      (else
  269.       (let ((maybe-predicate source))
  270.     maybe-predicate)))))
  271.  
  272. ;; Generates or'ed key predicate
  273. ;; (make-key-predicate '("<Control>j" "<Alt>k" "<Control>L"))
  274. (define make-key-predicate
  275.   (lambda (sources)
  276.     (cond
  277.      ((list? sources)
  278.       (let ((predicates (map make-single-key-predicate sources)))
  279.     (lambda (key key-state)
  280.       (apply proc-or
  281.          (map (lambda (predicate)
  282.             (apply predicate (list key key-state)))
  283.               predicates)))))
  284.      (else
  285.       (let ((source sources))
  286.     (make-single-key-predicate source))))))
  287.  
  288. (define modify-key-strs-implicitly
  289.   (lambda (key-strs)
  290.     (cond
  291.      ((list? key-strs)
  292.       (map modify-key-strs-implicitly key-strs))
  293.      ((string? key-strs)
  294.       (let* ((key-str key-strs)
  295.          (modified-key-str (string-append
  296.                 "<IgnoreRegularShift>"
  297.                 key-str)))
  298.     modified-key-str))
  299.      (else
  300.       (let ((maybe-predicate key-strs))
  301.     maybe-predicate)))))
  302.  
  303. ;; Generates or'ed key predicate and bind it into
  304. ;; toplevel-environment. Use define-key rather than calling this
  305. ;; directly.
  306. ;; (define-key-internal 'foo-key? '("<Control>j" "<Alt>k" "<Control>L"))
  307. (define define-key-internal
  308.   (lambda (key-predicate-sym key-strs)
  309.     (let* ((modified-key-strs (modify-key-strs-implicitly key-strs))
  310.        (predicate (make-key-predicate modified-key-strs)))
  311.       (eval (list 'define key-predicate-sym predicate)
  312.         (interaction-environment)))))
  313. (define-macro define-key
  314.   (lambda (key-predicate-sym key-strs)
  315.     `(define-key-internal ',key-predicate-sym ,key-strs)))
  316.  
  317. (define valid-key-str?
  318.   (lambda (key-str)
  319.     (let* ((parsed (parse-key-str key-str () -1 0))
  320.        (rest        (nth 0 parsed))
  321.        (translators (nth 1 parsed))
  322.        (key         (nth 2 parsed))
  323.        (key-state   (nth 3 parsed)))
  324.       (and (string? key-str)
  325.        (string=? rest "")
  326.        (not (eqv? key -1))))))
  327.  
  328. ;; 'strict-key-str' stands for key-str without translator-prefixes and
  329. ;; emacs like prefix
  330. (define valid-strict-key-str?
  331.   (lambda (key-str)
  332.     (let ((saved-enable-eprefix? enable-emacs-like-key-prefix?)
  333.       (res #f))
  334.       (set! enable-emacs-like-key-prefix? #f)
  335.       (let* ((parsed (parse-key-str key-str () -1 0))
  336.          (rest        (nth 0 parsed))
  337.          (translators (nth 1 parsed))
  338.          (key         (nth 2 parsed))
  339.          (key-state   (nth 3 parsed)))
  340.     (set! res (and (string? key-str)
  341.                (string=? rest "")
  342.                (null? translators)
  343.                (not (eqv? key -1)))))
  344.       (set! enable-emacs-like-key-prefix? saved-enable-eprefix?)
  345.       res)))
  346.  
  347. ;;
  348. (define-key left-key? "left")
  349. (define-key right-key? "right")
  350. (define-key switch-im-key? '("<Control>Shift_key" "<Shift>Control_key"))
  351.